home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmptop.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  54.5 KB  |  1,650 lines
  1. ;;; CMPTOP  Compiler top-level.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23. (import 'lisp::*link-array*)
  24.  
  25. (defvar *objects* nil)
  26. (defvar *constants* nil)
  27. (defvar *sharp-commas* nil)
  28. (defvar *function-links* nil)
  29. (defvar *c-gc* t) ;if we gc the c stack.
  30. (defvar *link-array* nil)
  31. (defvar *c-vars*)  ;list of *c-vars* to put at beginning of function.
  32. ;;number of address registers available not counting the
  33. ;;frame pointer and the stack pointer
  34. ;;If sup and base are used, then their are even 2 less
  35. ;;To do: If the regs hold data then there are really more available;
  36. (defvar *free-address-registers* 5)
  37. (defvar *free-data-registers* 6)
  38. ;;Inside t3defun this collects the list of downward closures defined.
  39. (defvar *downward-closures* nil)
  40.  
  41. (defvar *volatile*)
  42. (defvar *setjmps* 0)
  43.  
  44. ;; Functions may use a block of C stack space.
  45. ;; (cs . i)  will become Vcs[i].
  46.  
  47. (defvar *cs* 0)
  48.  
  49. ;; Holds list of local-functions resulting from c1function of
  50. ;; a lambda.  Is used to eliminate mix of downward and regular closures.
  51. (defvar *local-functions* nil)
  52.  
  53. (eval-when (load)
  54. (or *link-array* (setq *link-array*
  55.                (make-array 500 :element-type
  56.                    'fixnum :fill-pointer 0)))
  57.  
  58.  
  59. )
  60.  
  61.  
  62.  
  63. ;;; *objects* holds ( { object vv-index }* ).
  64. ;;; *constants* holds ( { symbol vv-index }* ).
  65. ;;; *sharp-commas* holds ( vv-index* ), indicating that the value
  66. ;;;  of each vv should be turned into an object from a string before
  67. ;;;  defining the current function during loading process, so that
  68. ;;;  sharp-comma-macros may be evaluated correctly.
  69. ;;; *function-links* ( {symbol vv-index} ) for function symbols needing link
  70.  
  71. (defvar *global-funs* nil)
  72.  
  73. ;;; *global-funs* holds
  74. ;;;     ( { global-fun-name cfun }* )
  75.  
  76. (defvar *closures* nil)
  77. (defvar *local-funs* nil)
  78.  
  79. ;;; *closure* holds fun-objects for closures.
  80.  
  81.  
  82.  
  83. (defvar *top-level-forms* nil)
  84. (defvar *non-package-operation* nil)
  85.  
  86. ;;; *top-level-forms* holds ( { top-level-form }* ).
  87. ;;;
  88. ;;;     top-level-form:
  89. ;;;      ( 'DEFUN'     fun-name cfun lambda-expr doc-vv sp)
  90. ;;;    | ( 'DEFMACRO'  macro-name cfun lambda-expr doc-vv sp)
  91. ;;;    | ( 'ORDINARY'  cfun expr)
  92. ;;;    | ( 'DECLARE'   var-name-vv )
  93. ;;;    | ( 'DEFVAR'    var-name-vv expr doc-vv)
  94. ;;;    | ( 'CLINES'    string )
  95. ;;;    | ( 'DEFCFUN'    header vs-size body)
  96. ;;;    | ( 'DEFENTRY'    fun-name cfun cvspecs type cfun-name )
  97. ;;;    | ( 'SHARP-COMMA' vv )
  98.  
  99. (defvar *reservations* nil)
  100. (defvar *reservation-cmacro* nil)
  101.  
  102. ;;; *reservations* holds (... ( cmacro . value ) ...).
  103. ;;; *reservation-cmacro* holds the cmacro current used as vs reservation.
  104.  
  105. (defvar *global-entries* nil)
  106.  
  107. ;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...).
  108.  
  109. ;;; Package operations.
  110.  
  111. (si:putprop 'make-package t 'package-operation)
  112. (si:putprop 'in-package t 'package-operation)
  113. (si:putprop 'shadow t 'package-operation)
  114. (si:putprop 'shadowing-import t 'package-operation)
  115. (si:putprop 'export t 'package-operation)
  116. (si:putprop 'unexport t 'package-operation)
  117. (si:putprop 'use-package t 'package-operation)
  118. (si:putprop 'unuse-package t 'package-operation)
  119. (si:putprop 'import t 'package-operation)
  120. (si:putprop 'provide t 'package-operation)
  121. (si:putprop 'require t 'package-operation)
  122.  
  123. ;;; Pass 1 top-levels.
  124.  
  125. (si:putprop 'eval-when 't1eval-when 't1)
  126. (si:putprop 'progn 't1progn 't1)
  127. (si:putprop 'defun 't1defun 't1)
  128. (si:putprop 'defmacro 't1defmacro 't1)
  129. (si:putprop 'clines 't1clines 't1)
  130. (si:putprop 'defcfun 't1defcfun 't1)
  131. (si:putprop 'defentry 't1defentry 't1)
  132. (si:putprop 'defla 't1defla 't1)
  133.  
  134. ;;; Top-level macros.
  135.  
  136. (si:putprop 'defconstant t 'top-level-macro)
  137. (si:putprop 'defparameter t 'top-level-macro)
  138. (si:putprop 'defstruct t 'top-level-macro)
  139. (si:putprop 'deftype t 'top-level-macro)
  140. (si:putprop 'defsetf t 'top-level-macro)
  141.  
  142. ;;; Pass 2 initializers.
  143.  
  144. (si:putprop 'defun 't2defun 't2)
  145. (si:putprop 'defmacro 't2defmacro 't2)
  146. (si:putprop 'ordinary 't2ordinary 't2)
  147. (si:putprop 'declare 't2declare 't2)
  148. (si:putprop 'sharp-comma 't2sharp-comma 't2)
  149. (si:putprop 'defentry 't2defentry 't2)
  150. (si:putprop 'si:putprop 't2putprop 't2)
  151.  
  152. ;;; Pass 2 C function generators.
  153.  
  154. (si:putprop 'defun 't3defun 't3)
  155. (si:putprop 'defmacro 't3defmacro 't3)
  156. (si:putprop 'clines 't3clines 't3)
  157. (si:putprop 'defcfun 't3defcfun 't3)
  158. (si:putprop 'defentry 't3defentry 't3)
  159.  
  160.       
  161. (eval-when (compile eval)
  162. (defmacro lambda-list (lambda-expr) `(caddr ,lambda-expr))
  163. (defmacro ll-requireds (lambda-list) `(car ,lambda-list))
  164. (defmacro ll-keywords (lambda-list) `(nth 4 ,lambda-list))
  165. (defmacro ll-optionals (lambda-list) `(nth 1 ,lambda-list))
  166. (defmacro ll-keywords-p (lambda-list) `(nth 3 ,lambda-list))
  167. (defmacro ll-rest (lambda-list) `(nth 2 ,lambda-list))
  168. (defmacro ll-allow-other-keys (lambda-list) `(nth 5 ,lambda-list))
  169. (defmacro vargd (min max)  `(+ ,min (ash ,max 8)))
  170. (defmacro let-pass3 (binds &body body &aux res)
  171.   (let ((usual '((*c-vars* nil)
  172.           (*vs* 0) (*max-vs* 0) (*level* 0) (*ccb-vs* 0) (*clink* nil)
  173.           (*unwind-exit* (list *exit*))
  174.           (*value-to-go* *exit*)
  175.           (*reservation-cmacro* (next-cmacro))
  176.           (*sup-used* nil)
  177.           (*restore-avma* nil)
  178.           (*base-used* nil)
  179.           (*cs* 0)
  180.           )))
  181.     (dolist (v binds)
  182.         (or (assoc (car v) usual)
  183.             (push v usual)))
  184.     (do ((v (setq usual (copy-list usual)) (cdr v)))
  185.         ((null v))
  186.          (let ((tem (assoc (caar v) binds)))
  187.          (if tem (setf (car v) tem))))
  188.     `(let* ,usual ,@body)))
  189. )
  190.  
  191.  
  192.  
  193. (defun t1expr (form &aux (*current-form* form) (*first-error* t))
  194.   (catch *cmperr-tag*
  195.     (when (consp form)
  196.       (let ((fun (car form)) (args (cdr form)) fd)
  197.            (declare (object fun args))
  198.            (cond
  199.             ((symbolp fun)
  200.              (cond ((eq fun 'si:|#,|)
  201.                     (cmperr "Sharp-comma-macro is in a bad place."))
  202.                    ((get fun 'package-operation)
  203.                     (when *non-package-operation*
  204.                       (cmpwarn "The package operation ~s was in a bad place."
  205.                                form))
  206.             (maybe-eval t form)
  207.                     (wt-data-package-operation form))
  208.                    ((setq fd (get fun 't1))
  209.                     (when *compile-print* (print-current-form))
  210.                     (funcall fd args))
  211.                    ((get fun 'top-level-macro)
  212.                     (when *compile-print* (print-current-form))
  213.                     (t1expr (cmp-macroexpand-1 form)))
  214.                    ((get fun 'c1) (t1ordinary form))
  215.                    ((setq fd (macro-function fun))
  216.             (let ((res
  217.                (cmp-expand-macro fd fun (copy-list (cdr form)))
  218.                ))
  219.               (t1expr res)))
  220.                    (t (t1ordinary form))
  221.                    ))
  222.             ((consp fun) (t1ordinary form))
  223.             (t (cmperr "~s is illegal function." fun)))
  224.            )))
  225.   )
  226.  
  227. (defvar *vaddress-list*)   ;; hold addresses of C functions, and other data
  228. (defvar *vind*)            ;; index in the VV array where the address is.
  229. (defvar *Inits*)
  230. (defun ctop-write (name &aux
  231.             def
  232.         (*function-links* nil) *c-vars* (*volatile* " VOL ")
  233.         *vaddress-list* (*vind* 0)  *inits*
  234.         *current-form*)
  235.   (declare (special *current-form*))
  236.  
  237.   (setq *top-level-forms* (reverse *top-level-forms*))
  238.  
  239.   ;;; Initialization function.
  240.   (wt-nl1     "init_" name "(){"
  241.           #+sgi3d "Init_Links ();"
  242.            "do_init(VV);"
  243.           "}")
  244.  
  245.  
  246.   ;; write all the inits.
  247.   (dolist* (*current-form* *top-level-forms*)
  248.        (setq *first-error* t)       
  249.            (when (setq def (get (car *current-form*) 't2))
  250.                  (apply def (cdr *current-form*))))
  251.  
  252.   
  253.   ;;; C function definitions.
  254.   (dolist* (*current-form* *top-level-forms*)
  255.        (setq *first-error* t)       
  256.            (when (setq def (get (car *current-form*) 't3))
  257.                  (apply def (cdr *current-form*))))
  258.  
  259.   ;;; Local function and closure function definitions.
  260.   (let (lf)
  261.        (block local-fun-process
  262.          (loop
  263.           (when (endp *local-funs*) (return-from local-fun-process))
  264.           (setq lf (car *local-funs*))
  265.           (pop *local-funs*)
  266.           (apply 't3local-fun lf))))
  267.  
  268.   ;;; Global entries for directly called functions.
  269.  
  270.   (dolist* (x *global-entries*)
  271.            (apply 'wt-global-entry x))
  272.   
  273.   ;;; Fastlinks
  274.   (dolist* (x *function-links*)
  275.        (wt-function-link x)
  276.        )
  277.   #+sgi3d
  278.   (progn
  279.     (wt-nl1 "" "static Init_Links () {")
  280.     (dolist* (x *function-links*)
  281.          (let ((num (second x)))
  282.            (wt-nl "Lnk" num " = LnkT" num ";")))
  283.     (wt-nl1 "}"))
  284.  
  285.   ;;; Declarations in h-file.
  286.   (dolist* (fun *closures*) (wt-h "static LC" (fun-cfun fun) "();"))
  287.   (dolist* (x *reservations*)
  288.            (wt-h "#define VM" (car x) " " (cdr x)))
  289.  
  290.   ;;*next-vv* is the index of the last entry pushed onto the data vector
  291.   ;;*vind* is the index of the next constant to be pushed.
  292.   ;;make sure enough room in VV to handle *vind*
  293.  
  294.   ;;reserve a spot for the Cdata which will be swapped for the (si::%init..):
  295.   (push-data-incf nil)
  296.  
  297.   ;Ensure there is enough room to write t
  298.   (dotimes (i (- *vind* *next-vv* +1))
  299.        (push-data-incf nil))
  300.    ;; now *next-vv* >= *vind* 
  301.  
  302.   ;; reserve space for the Cdata the cfdata object as the
  303.   ;; last entry in the VV vector.
  304.  
  305.  
  306.   (wt-h "static char * VVi[" (+ 1 *next-vv*) "]={")
  307.   (wt-h "#define Cdata VV[" *next-vv* "]")
  308.   (or *vaddress-list* (wt-h 0))
  309.    (do ((v (nreverse *Vaddress-List*) (cdr v)))
  310.        ((null v)   (wt-h "};"))
  311.        (wt-h "(char *)(" (caar v) (cadar v)  (if (cdr v) ")," ")")))
  312.  
  313.    (wt-h "#define VV ((object *)VVi)")
  314.  
  315.  
  316.    (wt-data-file)
  317.  
  318.  
  319.   (dolist (x *function-links* )
  320.       (let ((num (second x))
  321.         (type (third x)))
  322.         (cond ((eq type 'proclaimed-closure)
  323.            (wt-h "static object *Lclptr"num";")
  324.            (setq type ""))
  325.           (t
  326.            (setq type (if type (Rep-type type) ""))))
  327.  
  328.         (wt-h "static " type " LnkT" num "() ;") ;initial function.
  329.    #-sgi3d    (wt-h "static "  type " (*Lnk" num ")() = LnkT" num ";")
  330.    #+sgi3d    (wt-h "static "  type " (*Lnk" num ")();")))
  331.   )
  332.  
  333.  
  334. ;; this default will be as close to the the decision of the x3j13 committee
  335. ;; as I can make it.   Valid values of *eval-when-defaults* are
  336. ;; a sublist of '(compile eval load)
  337.  
  338. (defvar *eval-when-defaults* :defaults)
  339.  
  340. (defun maybe-eval (default-action form)
  341.   (or default-action (and (symbolp (car form))
  342.                 (setq default-action (get (car form) 'eval-at-compile))))
  343.   (cond ((or (and default-action (eq :defaults *eval-when-defaults*))
  344.          (and (consp *eval-when-defaults*)(member 'compile *eval-when-defaults* )))
  345.       (if form  (cmp-eval form))
  346.       t)))
  347.  
  348.  
  349. (defun t1eval-when (args &aux load-flag compile-flag)
  350.   (when (endp args) (too-few-args 'eval-when 1 0))
  351.   (dolist** (situation (car args))
  352.     (case situation
  353.           (load (setq load-flag t))
  354.           (compile (setq compile-flag t))
  355.           (eval)
  356.           (otherwise (cmperr "The EVAL-WHEN situation ~s is illegal."
  357.                              situation))))
  358.   (let ((*eval-when-defaults* (car args)))
  359.     (cond (load-flag
  360.        (t1progn (cdr args)))
  361.       (compile-flag
  362.        (cmp-eval (cons 'progn (cdr args)))))))
  363.  
  364.  
  365. (defvar *compile-ordinaries* nil)
  366.  
  367. (defun t1progn (args)
  368.   (cond ((equal (car args) ''compile)
  369.      (let ((*compile-ordinaries* t))
  370.        (t1progn (cdr args))))
  371.     (t
  372.      (dolist** (form args) (t1expr form)))))
  373.  
  374. ;; (defun foo (x) ..   -> (defun foo (g102 &aux (x g102)) ... 
  375. (defun  cmpfix-args (args bind &aux tem (lam (copy-list (second args))))
  376.   (dolist (v bind)
  377.       (setq tem (member (car v) lam))
  378.       (and tem
  379.            (setf (car tem) (second v))))
  380.   (cond ((setq tem (member '&aux lam))
  381.      (setf (cdr tem) (append bind (cdr tem))))
  382.     (t (setf lam (append lam (cons '&aux bind)))))
  383.   (list* (car args) lam (cddr args)))
  384.  
  385.  
  386.  
  387. (defun t1defun (args &aux (setjmps *setjmps*) (defun 'defun) (*sharp-commas* nil))
  388.   (when (or (endp args) (endp (cdr args)))
  389.         (too-few-args 'defun 2 (length args)))
  390.   (cmpck (not (symbolp (car args)))
  391.          "The function name ~s is not a symbol." (car args))
  392.   (maybe-eval nil  (cons 'defun args))
  393.  (tagbody
  394.    top
  395.   (setq *non-package-operation* t)
  396.   (setq *local-functions* nil)
  397.   (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr
  398.          (*special-binding* nil)
  399.         (cfun (or (get (car args) 'Ufun) (next-cfun)))
  400.         (doc nil) (fname (car args)))
  401.        (declare (object fname))
  402.        (setq lambda-expr (c1lambda-expr (cdr args) fname))
  403.   (or (eql setjmps *setjmps*) (setf (info-volatile (cadr lambda-expr)) t))
  404.   (check-downward (info-referred-vars (cadr lambda-expr)))
  405.  
  406. ;;provide a simple way for the user to declare functions to
  407. ;;have fixed args without having to count them, and make mistakes.
  408.   (cond ((get fname 'fixed-args)
  409.      ;the number of regular args in definition
  410.      (let ((n  (length (car (lambda-list lambda-expr)))))
  411.        (setf (get fname 'fixed-args)  n);;for error checking.
  412.        (proclaim (list 'function fname
  413.                (make-list n :initial-element t) t)))))
  414.         
  415.   (cond
  416.    ((and
  417.       (get fname 'proclaimed-function)
  418.       ;; check the args:
  419.       (let ((lambda-list (lambda-list lambda-expr))bind)
  420.         (declare (object lambda-list))
  421.         (and (null (cadr lambda-list))    ;;; no optional
  422.          (null (caddr lambda-list))    ;;; no rest
  423.          (null (cadddr lambda-list))    ;;; no keyword
  424.          (< (length (car lambda-list)) call-arguments-limit)
  425.                         ;;; less than 10 requireds
  426.            ;;; For all required parameters...
  427.          (do ((vars (car lambda-list) (cdr vars))
  428.               (types (get fname 'proclaimed-arg-types) (cdr types))
  429.               (problem))
  430.              ((endp vars)
  431.               (and (endp types)
  432.                (cond (bind (setq args (cmpfix-args args bind))
  433.                        (go top))
  434.                  (t (not problem)))))
  435.              (declare (object vars types))
  436.              (let ((var (car vars)))
  437.                (declare (object var))
  438.                (cond  ((equal (car types) '*)(return nil)))
  439.                (unless
  440.              (and
  441.                (or (and (or (eq (var-kind var) 'LEXICAL)
  442.                     (and (eq (var-kind var)
  443.                          'special)
  444.                          (eq (car types) t)))
  445.                     (not (var-ref-ccb var))
  446.                     (not (eq (var-loc var) 'clb)))
  447.                    (progn (push (list 
  448.                           (var-name var) (gensym))
  449.                         bind)
  450.                       t))
  451.                (type-and (car types) (var-type var))
  452.                (or (member (car types)
  453.                        '(fixnum character
  454.                         long-float short-float))
  455.                    (eq (var-loc var) 'object)
  456.                    *c-gc* 
  457.                     (not (member var
  458.                               (info-changed-vars
  459.                             (cadr lambda-expr))))))
  460.                                     
  461.              (unless bind
  462.                  (cmpwarn "Calls to ~a will be VERY SLOW. Recommend not to proclaim.  ~%;;The arg caused the problem. ~a"
  463.                       fname  (var-name var)))
  464.              (setq problem t))))
  465.          (numberp cfun))))
  466.     ;;whew: it is acceptable.
  467.         (push (list fname
  468.                     (get fname 'proclaimed-arg-types)
  469.                     (get fname 'proclaimed-return-type)
  470.             (flags set ans)
  471.                     (make-inline-string
  472.                      cfun (get fname 'proclaimed-arg-types)))
  473.               *inline-functions*))
  474.    ((and ;(get fname 'proclaimed-function)
  475.      (eq (get fname 'proclaimed-return-type) t))
  476. ;    (setq me lambda-list)
  477. ;    (setq me (lambda-list lambda-expr))
  478.     
  479. ;    (print args)
  480.     ))
  481.     ;; variable number of args;
  482.      
  483.  
  484.  
  485.        (when (cadddr lambda-expr)
  486.              (setq doc  (cadddr lambda-expr)))
  487.        (add-load-time-sharp-comma)
  488.        (push (list defun fname cfun lambda-expr doc *special-binding*)
  489.              *top-level-forms*)
  490.        (push (cons fname cfun) *global-funs*)
  491.  
  492.        
  493.        )))
  494.  
  495. (defun make-inline-string (cfun args)
  496.   (if (null args)
  497.       (format nil "LI~d()" cfun)
  498.       (let ((o (make-array 100 :element-type 'string-char :fill-pointer 0
  499.                :adjustable t )))
  500.            (format o "LI~d(" cfun)
  501.            (do ((l args (cdr l))
  502.                 (n 0 (1+ n)))
  503.                ((endp (cdr l))
  504.                 (format o "#~d)" n))
  505.                (declare (fixnum n))
  506.                (format o "#~d," n))
  507.            o)))
  508.  
  509.  
  510.  
  511. (defun cs-push (&optional type)
  512.   (let ((tem (next-cvar)))
  513.     (push (if type (cons type tem) tem) *c-vars*)
  514.     tem))
  515. ; For the moment only two types are recognized.
  516. (defun f-type (x)
  517.   (if (var-p x) (setq x (var-type x)))
  518.   (cond ((and x (subtypep x 'fixnum))
  519.      1)
  520.     (t 0)))
  521.  
  522.  
  523. (defun proclaimed-argd (args return)
  524.   (let ((ans (length args))
  525.     (i 8)
  526.     (type (the fixnum (f-type return)))
  527.     (begin t))
  528.     (declare (fixnum ans i))
  529.     (loop
  530.      (if (not (eql 0 type))
  531.      (setq ans (the fixnum (+ ans
  532.                   (the fixnum (ash (the fixnum type)
  533.                            (the (integer 0 30)
  534.                             i)))))))
  535.      (when  begin (setq i 10) (setq begin nil))
  536.      (if (null args) (return ans))
  537.      (setq i (the fixnum (+ i 2)))
  538.      (setq type (f-type (pop args))))))
  539.     
  540.  
  541. (defun wt-if-proclaimed (fname cfun  lambda-expr)
  542.   (cond ((fast-link-proclaimed-type-p fname)
  543.      (cond ((assoc fname *inline-functions*)
  544.         (add-init `(si::mfsfun ',fname ,(add-address "LI" cfun)
  545.                    ,(proclaimed-argd (get fname 'proclaimed-arg-types)
  546.                              (get fname 'proclaimed-return-type)
  547.                     )           )
  548.               )
  549.         t)
  550.            (t
  551.         (let ((arg-c (length (car (lambda-list lambda-expr))))
  552.               (arg-p (length (get fname 'proclaimed-arg-types)))
  553.               (va  (member '* (get fname 'proclaimed-arg-types))))
  554.           (cond (va
  555.              (or (>= arg-c)
  556.                  (- arg-p (length va))
  557.                  (cmpwarn "~a needs ~a args. ~a supplied."
  558.                       fname   (- arg-p (length va))
  559.                       arg-c)))
  560.                       
  561.             ((not (eql arg-c arg-p))
  562.              (cmpwarn
  563.              "~%;; ~a Number of proclaimed args was ~a. ~
  564.                           ~%;;Its definition had ~a." fname arg-p arg-c))
  565.             ;((>= arg-c 10.)) ;checked above 
  566.              ;(cmpwarn " t1defun only likes 10 args ~
  567.                          ;            ~%for proclaimed functions")
  568.             (t (cmpwarn
  569.             " ~a is proclaimed but not in *inline-functions* ~
  570.         ~%T1defun could not assure suitability of args for C call" fname
  571.             ))))
  572.         nil)))))    
  573.     
  574.  
  575. (defun volatile (info)
  576.    (if  (info-volatile info) "VOL " ""))
  577.  
  578. (defun register (var)
  579.   (cond ((and (equal *volatile* "")
  580.           (>= (the fixnum (var-register var))
  581.           (the fixnum *register-min*)))
  582.      "register ")
  583.     (t "")))
  584.  
  585. (defun vararg-p (x)
  586.   (and (equal (get x 'proclaimed-return-type) t)
  587.        (do ((v (get x 'proclaimed-arg-types) (cdr v)))
  588.        ((null v) t)
  589.        (or (consp v) (return nil))
  590.        (or (eq (car v) t)
  591.            (eq (car v) '*)
  592.            (return nil)))))
  593.  
  594.  
  595. (defun maxargs (lambda-list)
  596.   (cond ((or (ll-allow-other-keys lambda-list)(ll-rest lambda-list))
  597.      64)
  598.     (t (+ (length (car lambda-list)) ;reg
  599.           (length (ll-optionals lambda-list))
  600.           (* 2 (length (ll-keywords lambda-list)))))))
  601.  
  602.  
  603.  
  604.   
  605. (defun add-address (a b)
  606.   ;; if need ampersand before function for address
  607.   ;; (setq a (string-concatenate "&" a))
  608.   (push (list a b) *vaddress-list*)
  609.   (prog1 *vind* (incf *vind*)))
  610.  
  611. (defun t2defun (fname cfun lambda-expr doc sp)
  612.   (declare (ignore  sp))
  613.   (cond ((get fname 'no-global-entry)(return-from t2defun nil)))
  614.  
  615.   (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) ))
  616.   
  617.   (cond ((wt-if-proclaimed fname cfun lambda-expr))
  618.     ((vararg-p fname)
  619.      (let ((keyp (ll-keywords-p (lambda-list lambda-expr))))
  620.        (wt-h "static object LI" cfun "();")
  621.        (if keyp
  622.          (add-init `(si::mfvfun-key
  623.              ',fname ,(add-address "LI" cfun)
  624.              ,(vargd (length (car (lambda-list lambda-expr)))
  625.                  (maxargs (lambda-list lambda-expr)))
  626.              ,(add-address (format nil "&LI~akey" cfun) ""))
  627.            )
  628.          (add-init `(si::mfvfun ',fname ,(add-address "LI" cfun)
  629.                 ,(vargd (length (car (lambda-list lambda-expr)))
  630.                        (maxargs (lambda-list lambda-expr))))
  631.            ))))
  632.     ((numberp cfun)
  633.          (wt-h "static L" cfun "();")
  634.      (add-init `(si::mf ',fname ,(add-address "L" cfun)) ))
  635.         (t (wt-h cfun "();")
  636.        (add-init `(si::mf ',fname ,(add-address "" cfun )) )))
  637.            
  638.     (cond ((< *space* 2)
  639.            (setf (get fname 'debug-prop) t)
  640.        )))
  641.  
  642. (defun si::add-debug (fname x)
  643.   (si::putprop fname x  'si::debug))
  644.  
  645. (defun t3defun (fname cfun lambda-expr doc sp &aux inline-info 
  646.               (*current-form* (list 'defun fname))
  647.               (*volatile* (volatile (second lambda-expr)))
  648.               *downward-closures*)
  649.   (declare (ignore doc))
  650.   (cond
  651.    ((dolist (v *inline-functions*)
  652.       (or (si::fixnump (nth 3 v))
  653.       (error "Old style inline"))
  654.        (and (eq (car v) fname)
  655.                  (not (nth 5 v)) ; ie.not  'link-call or 'ifuncall
  656.          (return (setq inline-info v))))
  657.  
  658.     ;;; Add global entry information.
  659.     (when (not (fast-link-proclaimed-type-p fname))
  660.       (push (list fname cfun (cadr inline-info) (caddr inline-info))
  661.         *global-entries*))
  662.  
  663.     ;;; Local entry
  664.     (analyze-regs (info-referred-vars (cadr lambda-expr)) 0)
  665.     (t3defun-aux 't3defun-local-entry
  666.          (case (caddr inline-info)
  667.            (fixnum 'return-fixnum)
  668.                          (character 'return-character)
  669.                          (long-float 'return-long-float)
  670.                          (short-float 'return-short-float)
  671.                          (otherwise 'return-object))
  672.          fname cfun lambda-expr sp inline-info
  673.     ))
  674.    ((vararg-p fname)
  675.     (analyze-regs (info-referred-vars (cadr lambda-expr)) 0)
  676.     (t3defun-aux 't3defun-vararg 'return-object
  677.          fname cfun lambda-expr sp))
  678.    (t
  679.     (analyze-regs (info-referred-vars (cadr lambda-expr)) 2)
  680.     (t3defun-aux 't3defun-normal 'return fname cfun lambda-expr sp)))
  681.   
  682.   (wt-downward-closure-macro cfun)
  683.   (add-debug-info fname lambda-expr))
  684.  
  685. (defun t3defun-aux (f *exit* &rest lis)
  686.   (let-pass3 ()   (apply f lis)))   
  687.  
  688. (defun t3defun-local-entry (fname cfun lambda-expr sp inline-info
  689.                    &aux specials
  690.                    (requireds   (caaddr lambda-expr)))
  691.   (do ((vl requireds (cdr vl))
  692.        (types (cadr inline-info) (cdr types)))
  693.       ((endp vl))
  694.       (declare (object vl types))
  695.       (cond ((eq (var-kind (car vl)) 'special)
  696.               (push (cons (car vl) (var-loc (car vl))) specials))
  697.             (t
  698.              (setf (var-kind (car vl))
  699.                    (case (car types)
  700.                          (fixnum 'FIXNUM)
  701.                          (character 'CHARACTER)
  702.                          (long-float 'LONG-FLOAT)
  703.                          (short-float 'SHORT-FLOAT)
  704.                          (otherwise 'OBJECT))))
  705.                    )
  706.              (setf (var-loc (car vl)) (next-cvar)))
  707.          (wt-comment "local entry for function " fname)
  708.          (wt-h "static " (rep-type (caddr inline-info)) "LI" cfun "();")
  709.          (wt-nl1 "static " (rep-type (caddr inline-info)) "LI" cfun "(")
  710.          (wt-requireds  requireds
  711.                (cadr inline-info))
  712.          ;;; Now the body.
  713.          (let ((cm *reservation-cmacro*)
  714.            (*tail-recursion-info*
  715.             (if *do-tail-recursion* (cons fname requireds) nil))
  716.            (*unwind-exit* *unwind-exit*))
  717.               (wt-nl1 "{    ")
  718.                (assign-down-vars (info-referred-vars (cadr lambda-expr)) cfun
  719.           't3defun)
  720.                 (wt " VMB" cm " VMS" cm " VMV" cm)
  721.  
  722.               (when sp (wt-nl "bds_check;"))
  723.               (when *compiler-push-events* (wt-nl "ihs_check;"))
  724.               (when *tail-recursion-info*
  725.                     (push 'tail-recursion-mark *unwind-exit*)
  726.                     (wt-nl1 "TTL:;"))
  727.               (dolist
  728.                 (v specials)
  729.               (wt-nl "bds_bind(VV[" (cdr v)"],V" (var-loc (car v))");")
  730.               (push 'bds-bind *unwind-exit*)
  731.           (setf (var-kind (car v)) 'SPECIAL)
  732.           (setf (var-loc (car v)) (cdr v)))
  733.               (c2expr (caddr (cddr lambda-expr)))
  734.               
  735.               (wt-nl1 "}")
  736.           (wt-V*-macros cm (caddr inline-info))
  737.          ))
  738.  
  739.  
  740.  
  741. (defvar *vararg-use-vs* nil)
  742. (defun set-up-var-cvs (var)
  743.           (cond (*vararg-use-vs* 
  744.              (setf (var-ref var) (vs-push)))
  745. ;            ((numberp (var-loc var)))
  746.             (t (setf (var-ref var) (cvs-push)))))
  747.  
  748. (defun t3defun-vararg (fname cfun lambda-expr sp &aux  reqs *vararg-use-vs*
  749.                  block-p labels (deflt t) key-offset
  750.                  (*inline-blocks* 0) rest-var
  751.                  (ll (lambda-list lambda-expr)) va-start
  752.                  (is-var-arg (or (ll-rest ll)
  753.                          (ll-optionals ll)
  754.                          (ll-keywords-p ll))))
  755.   (dolist (v (car ll))
  756.       (push (list 'cvar (next-cvar)) reqs))
  757.  
  758.   (wt-comment "local entry for function " fname)
  759.   (wt-h "static object LI" cfun "();")
  760.   (wt-nl1 "static object LI" cfun "(")
  761.   (wt-list reqs)
  762.   (when is-var-arg
  763.     (if reqs (wt ","))
  764.     (wt "va_alist"))
  765.   (wt ")")
  766.   (when reqs (wt-nl "object ")
  767.     (wt-list reqs)  (wt ";"))
  768.   (if is-var-arg (wt-nl "va_dcl "))
  769.          ;;; Now the body.
  770.    
  771.   (let ((cm *reservation-cmacro*)
  772.     (*tail-recursion-info*
  773.      ;; to do:  When can we do tail recursion?
  774.      ;; Should be able to do the optionals case, where the
  775.      ;; optional defaults are constants.    But this
  776.      ;; is probably not worth it.
  777.      (and
  778.       *do-tail-recursion*
  779.       (not (ll-rest ll))
  780.       (dolist* (var (ll-requireds ll) t)
  781.            (when (var-ref-ccb var) (return nil)))
  782.       (null (ll-optionals ll))
  783.       (null (ll-keywords ll))
  784.       (cons fname (car ll))))
  785.     (*unwind-exit* *unwind-exit*))
  786.     (wt-nl1 "{    ")
  787.     (when is-var-arg      (wt-nl "va_list ap;"))
  788.     (wt-nl "int narg = VFUN_NARGS;")
  789.  
  790.     (assign-down-vars (info-referred-vars (cadr lambda-expr)) cfun
  791.               't3defun)
  792.     (wt " VMB" cm " VMS" cm " VMV" cm)
  793.  
  794.     (when sp (wt-nl "bds_check;"))
  795.     (when *compiler-push-events* (wt-nl "ihs_check;"))
  796.     (or is-var-arg (wt-nl "if ( narg!= " (length reqs) ") vfun_wrong_number_of_args(small_fixnum("
  797.               (length reqs)
  798.               "));"))
  799.  
  800.     (flet ((do-decl (var)
  801.             (and (eql (var-loc var) 'clb) (setf *vararg-use-vs* t))
  802.             (let ((kind (c2var-kind var)))
  803.               (declare (object kind))
  804.               (when kind
  805.                 (let ((cvar (next-cvar)))
  806.                   (setf (var-kind var) kind)
  807.                   (setf (var-loc var) cvar)
  808.                   (wt-nl)
  809.                   (unless block-p (wt "{") (setq block-p t))
  810.                   (wt-var-decl var)
  811.                   )))))
  812.  
  813.       (dolist** (var (car ll))
  814.             (do-decl var))
  815.       (dolist** (opt (ll-optionals ll))
  816.             (do-decl (car opt))
  817.             (when (caddr opt) (do-decl (caddr opt))))
  818.       (when (ll-rest ll) (do-decl (ll-rest ll)))
  819.       (dolist** (kwd (ll-keywords ll))
  820.             (do-decl (cadr kwd))
  821.             (when (cadddr kwd) (do-decl (cadddr kwd))))
  822.       )
  823.  
  824.   ;;; Check arguments.
  825.     (when (and (or *safe-compile* *compiler-check-args*) (car ll))
  826.       (wt-nl "if(narg <" (length (car ll))
  827.          ") too_few_arguments();"))
  828.  
  829.   ;;; Allocate the parameters.
  830.     (dolist** (var (car ll))    (set-up-var-cvs var))
  831.     (dolist** (opt (ll-optionals ll))  (set-up-var-cvs (car opt)))
  832.           
  833.  
  834.     (when (ll-rest ll) (set-up-var-cvs (ll-rest ll))) 
  835.  
  836.     (setf key-offset (if *vararg-use-vs* *vs* *cs*))
  837.     (dolist** (kwd (ll-keywords ll))
  838.            (set-up-var-cvs (cadr kwd)))
  839.     (dolist** (kwd (ll-keywords ll))
  840.            (set-up-var-cvs (cadddr kwd)))
  841.  
  842.     ;;bind the params:
  843.     (do ((v reqs (cdr v))
  844.      (vl (car ll) (cdr vl)))
  845.     ((null v))
  846.     (c2bind-loc (car vl) (car v)))
  847.    (when (ll-optionals ll)
  848.      (let ((*clink* *clink*)
  849.            (*unwind-exit* *unwind-exit*)
  850.            (*ccb-vs* *ccb-vs*))
  851.        (wt-nl "narg = narg - " (length reqs) ";")
  852.     (dolist** (opt (ll-optionals ll))
  853.      (push (next-label) labels)
  854.      (wt-nl "if (" (if (cdr labels) "--" "") "narg <= 0) ")
  855.      (wt-go (car labels))
  856.      (wt-nl "else {" )
  857.      (unless va-start (setq va-start t) (wt-nl "va_start(ap);"))
  858.      (c2bind-loc (car opt) (list 'next-var-arg))
  859.      (wt "}")
  860.      (when (caddr opt) (c2bind-loc (caddr opt) t))))
  861.      (setq labels (nreverse labels))
  862.  
  863.     (let ((label (next-label)))
  864.              (wt-nl "--narg; ")
  865.              (wt-go label)
  866.  
  867.              ;;; Bind unspecified optional parameters.
  868.  
  869.              (dolist** (opt (ll-optionals ll))
  870.                        (wt-label (car labels))
  871.                        (pop labels)
  872.                        (c2bind-init (car opt) (cadr opt))
  873.                        (when (caddr opt) (c2bind-loc (caddr opt) nil)))
  874. ;         (if (or (ll-rest ll)(ll-keywords-p ll))(wt-nl "narg=0;"))
  875.  
  876.              (wt-label label)
  877.              ))
  878.    (if (ll-rest ll)
  879.        (progn
  880.      (setq rest-var (cs-push))
  881.      (cond ((ll-optionals ll))
  882.            (t (wt-nl "narg= narg - " (length (car ll)) ";")))
  883.      (unless va-start (setq va-start t) (wt-nl "va_start(ap);"))
  884.      (wt-nl "V" rest-var " = ")
  885.      
  886.      (let ((*rest-on-stack*
  887.         (or (eq (var-type (ll-rest ll)) :dynamic-extent)
  888.             *rest-on-stack*)))
  889.        (if (ll-keywords-p ll)
  890.          (cond (*rest-on-stack*
  891.             (wt "(ALLOCA_CONS(narg),ON_STACK_MAKE_LIST(narg));"))
  892.            (t (wt "make_list(narg);")))
  893.          (cond (*rest-on-stack*
  894.             (wt "(ALLOCA_CONS(narg),ON_STACK_LIST_VECTOR(narg,ap));"
  895.             ))
  896.            (t  (wt "list_vector(narg,ap);"))))
  897.        (c2bind-loc (ll-rest ll) (list 'cvar rest-var)))))
  898.    (when (ll-keywords-p ll)
  899.      (cond ((ll-rest ll))
  900.            ((ll-optionals ll))
  901.            (t (wt-nl "narg= narg - " (length (car ll)) ";")))
  902.         
  903.      (unless va-start (setq va-start t) (wt-nl "va_start(ap);"))
  904.      (setq deflt (mapcar 'caddr (ll-keywords ll)))
  905.      (let ((vkdefaults nil)
  906.            (n (length (ll-keywords ll))))
  907.      (do* ((v deflt (cdr v))
  908.           (kwds (ll-keywords ll) (cdr kwds))
  909.           (kwd (car kwds) (car kwds)))
  910.          ((null v))
  911.          (unless (and (eq (caar v)  'location)
  912.               (eq (third (car v)) nil))
  913.              (setq vkdefaults t))
  914.          (when (or (not (and (eq (caar v) 'location)
  915.                  (let ((tem (third (car v))))
  916.                    (or (eq tem nil)
  917.                        (and (consp tem)
  918.                         (member (car tem)
  919.                             '(vv fixnum-value))
  920.                         )))))
  921.                ;; the supplied-p variable is not there
  922.                (not (eq (var-kind (cadddr kwd)) 'DUMMY)))
  923.            (setf Vkdefaults t)
  924.            (setf (car v) 0)))
  925.      (if (> (length deflt) 15) (setq vkdefaults t))
  926.  
  927.      (wt-nl "{")
  928.      (inc-inline-blocks)
  929.      (let ((*compiler-output1* *compiler-output2*))
  930.        (when vkdefaults
  931.          (terpri *compiler-output2*)
  932.          (wt "static int VK" cfun
  933.             "defaults[" (length deflt) "]={")
  934.          (do ((v deflt(cdr v))(tem))
  935.              ((null v))
  936.              (cond ((eql (car v) 0)
  937.                 (wt "-1"))
  938.                ;; must be location
  939.                ((and (eq (setq tem (third (car v))) nil))
  940.                 (wt "-2"))
  941.                ((and (consp tem) (eq (car tem) 'vv))
  942.                 (wt  (second tem) ))
  943.                ((and (consp tem) (eq (car tem) 'fixnum-value))
  944.                 (wt (add-object(third tem)) ))
  945.                (t (baboon)))
  946.                   
  947.              (if (cdr v) (wt ",")))
  948.          (wt "};"))
  949.        (terpri *compiler-output2*)
  950.        (wt "static struct { short n,allow_other_keys;"
  951.           "int *defaults;")
  952.        (wt-nl " int keys[" n "];")
  953.        (wt "} LI"cfun "key=")
  954.         
  955.        (wt "{" (length (ll-keywords ll)) ","
  956.            (if (ll-allow-other-keys ll) 1 0)
  957.            ",")
  958.        (if vkdefaults (wt "VK" cfun "defaults")
  959.          (wt "(int *)Cstd_key_defaults"))
  960.        (when (ll-keywords ll)
  961.          (wt ",{")
  962.          (do ((v (reverse (ll-keywords ll)) (cdr v)))
  963.              ((null v))
  964.              ;; We write this list backwards for convenience
  965.              ;; in stepping through it in parse_key
  966.              (wt  (add-symbol (caar v))  )
  967.              (if (cdr v) (wt ",")))
  968.          (wt "}"))
  969.        (wt "};")
  970.        )
  971.      (cond ((ll-rest ll)
  972.         (wt-nl "parse_key_rest(" (list 'cvar rest-var) ","))
  973.            (t (wt-nl "parse_key_new(")))
  974.      (if (eql 0 *cs*)(setq *cs* 1))
  975.      (wt "narg," (if *vararg-use-vs* "base " "Vcs ")
  976.          "+" key-offset",&LI" cfun "key,ap);")
  977.        
  978.        ))
  979.  
  980.  
  981.  
  982.    ;; bind keywords
  983.  
  984.    (dolist** (kwd (ll-keywords ll))
  985.     (cond ((not (eql 0 (pop deflt)))
  986.        ;; keyword default bound by parse_key.. and no supplied-p
  987.            (c2bind (cadr kwd)))
  988.           (t
  989.            (wt-nl "if(") (wt-vs (var-ref (cadr kwd))) (wt "==0){")
  990.            (let ((*clink* *clink*)
  991.                  (*unwind-exit* *unwind-exit*)
  992.                  (*ccb-vs* *ccb-vs*))
  993.                 (c2bind-init (cadr kwd) (caddr kwd)))
  994.        (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd) nil))
  995.  
  996.            (wt-nl "}else{")
  997.            (c2bind (cadr kwd))
  998.        (unless (eq (var-kind (cadddr kwd)) 'DUMMY) (c2bind-loc (cadddr kwd)
  999.                                    t))
  1000.  
  1001.            (wt "}")))
  1002.  
  1003.  
  1004.  
  1005.    )
  1006.    (when *tail-recursion-info*
  1007.      (push 'tail-recursion-mark *unwind-exit*)
  1008.      (wt-nl1 "TTL:;"))
  1009.    (c2expr (caddr (cddr lambda-expr)))
  1010.         
  1011.   (wt "}") 
  1012.   (when block-p (wt-nl "}"))
  1013.   (close-inline-blocks)
  1014.   (wt-V*-macros cm (get fname 'proclaimed-return-type))
  1015.             ))
  1016.  
  1017. (defun t3defun-normal (fname cfun lambda-expr sp)
  1018.          (wt-comment "function definition for " fname)
  1019.          (if (numberp cfun)
  1020.              (wt-nl1 "static L" cfun "()")
  1021.              (wt-nl1 cfun "()"))
  1022.          (wt-nl1 "{" "register object *"  *volatile*"base=vs_base;")
  1023.      (assign-down-vars (info-referred-vars (cadr lambda-expr)) cfun
  1024.                't3defun)
  1025.          (wt-nl 
  1026.         "register object *" *volatile*"sup=base+VM" *reservation-cmacro* ";")
  1027.           (wt " VC" *reservation-cmacro*)
  1028.          (if *safe-compile*
  1029.              (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  1030.              (wt-nl "vs_check;"))
  1031.          (when sp (wt-nl "bds_check;"))
  1032.          (when *compiler-push-events* (wt-nl "ihs_check;"))
  1033.          (c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)) fname)
  1034.          (wt-nl1 "}")
  1035.          (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  1036.  
  1037.        (wt-h "#define VC" *reservation-cmacro*)
  1038.        (wt-cvars)
  1039.  
  1040.          )
  1041.  
  1042.  
  1043. ;;Macros for conditionally writing vs_base ..preamble, and for setting
  1044. ;;up the return.
  1045. (defun wt-V*-macros (cm return-type)
  1046.   (push (cons cm *max-vs*) *reservations*)
  1047.   (if (and (zerop *max-vs*) (not *sup-used*) (not *base-used*))
  1048.       ;;note if (proclaim '(function foo () t))
  1049.       ;;(defun foo () (goo)) ;then *max-vs*=0,*sup-used*=t;--wfs
  1050.       (wt-h "#define VMB" cm)
  1051.     (wt-h "#define VMB" cm " " 
  1052.       "register object *" *volatile*"base=vs_top;"))
  1053.   ;;tack following onto the VMB macro..
  1054.   (wt-cvars)
  1055.   (if *sup-used*
  1056.       (wt-h "#define VMS" cm
  1057.         " "  " register object *" *volatile*"sup=vs_top+" *max-vs*
  1058.         ";vs_top=sup;")
  1059.     (if (zerop *max-vs*)
  1060.     (wt-h "#define VMS" cm)
  1061.       (wt-h "#define VMS" cm " vs_top += " *max-vs* ";")))
  1062.   (if (zerop *max-vs*)
  1063.       (wt-h "#define VMV" cm)
  1064.     (if *safe-compile*
  1065.     (wt-h "#define VMV" cm " vs_reserve(" *max-vs* ");")
  1066.       (wt-h "#define VMV" cm " vs_check;")))
  1067.   (if (zerop *max-vs*)
  1068.       (wt-h "#define VMR" cm "(VMT" cm ") return(VMT" cm ");")
  1069.     (wt-h "#define VMR" cm "(VMT" cm ") vs_top=base ; return(VMT" cm ");"))
  1070.   )
  1071.  
  1072. ;;Write the required args as c arguments, and declarations for the arguments.
  1073. (defun wt-requireds (requireds arg-types)
  1074.   (do ((vl requireds (cdr vl)))
  1075.       ((endp vl))
  1076.       (declare (object vl))
  1077.       (let ((cvar (next-cvar)))
  1078.     (setf (var-loc (car vl)) cvar)
  1079.     (wt "V" cvar))
  1080.       (unless (endp (cdr vl)) (wt ",")))
  1081.   (wt ")
  1082. ")
  1083.   (when requireds
  1084.     (wt-nl1)
  1085.     (do ((vl requireds (cdr vl))
  1086.          (types arg-types (cdr types))
  1087.          (prev-type nil))
  1088.         ((endp vl) (wt ";"))
  1089.         (declare (object vl))
  1090.  
  1091.         (if prev-type (wt ";"))
  1092.                  
  1093.         (wt *volatile* (register (car vl))
  1094.         (rep-type (car types)))    
  1095.         (setq prev-type (car types))
  1096.         (wt "V" (var-loc (car vl))))))
  1097.  
  1098.  
  1099. (defun add-debug-info (fname lambda-expr &aux locals)
  1100.   (cond
  1101.    ((>= *space* 2))
  1102.    ((null (get fname 'debug-prop))
  1103.       (warn "~a has a duplicate definition in this file" fname))
  1104.    (t
  1105.     (remprop fname 'debug-prop)
  1106.     (let ((leng 0))
  1107.       (dolist (va (info-referred-vars (second lambda-expr)))
  1108.           (when (and (consp (var-ref va))
  1109.              (si::fixnump (cdr (var-ref va))))
  1110.         (setq leng (max leng (cdr (var-ref va))))))
  1111.       (setq locals (make-list (1+ leng)))
  1112.       (dolist (va (info-referred-vars (second lambda-expr)))
  1113.           (when (and (consp (var-ref va))  ;always fixnum ?
  1114.              (si::fixnump (cdr (var-ref va))))
  1115.             (setf (nth (cdr (var-ref va)) locals)
  1116.               (var-name va))))
  1117.       (setf (get fname 'si::debug) locals)
  1118.       (let ((locals (get fname 'si::debug)))
  1119.     (if (and locals (or (cdr locals) (not (null (car locals)))))
  1120.         (add-init `(si::debug ',fname ',locals) )
  1121.         ))
  1122.       ))))
  1123.  
  1124.  
  1125. ;;Checks the register slots of variables, and finds which
  1126. ;;variables should be in registers, zero'ing the register slot
  1127. ;;in the remaining.  Data and address variables are done separately.
  1128. (defun analyze-regs (vars for-sup-base)
  1129.   (let ((addr-regs (- *free-address-registers* for-sup-base)))
  1130.   (cond ((zerop *free-data-registers*)
  1131.      (analyze-regs1 (remove-duplicates vars) addr-regs))
  1132.     (t
  1133.      (let (addr data)
  1134.        (dolist (v vars)
  1135.          (cond ((member
  1136.              (var-type v)'(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT)
  1137.              :test 'eq)
  1138.             (or (member v data) (push v data)))
  1139.            (t (or (member v addr :test 'eq) (push v data)))))
  1140.        (analyze-regs1 addr addr-regs)
  1141.        (analyze-regs1 data *free-data-registers*))))))
  1142.  
  1143. (defun analyze-regs1 (vars want )
  1144.   (let ((tem 0)(real-min 3)(this-min 100000)(want want)(have 0))
  1145.     (declare (fixnum tem real-min this-min  want have))
  1146.     (setq vars (remove-duplicates vars))
  1147.   (tagbody
  1148.    START
  1149.    (dolist (v vars)
  1150.        (setq tem (var-register v))
  1151.        (cond ((>= tem real-min)
  1152.           (setq have (the fixnum (+ have 1)))
  1153.           (cond ((< tem this-min )
  1154.              (setq this-min tem)))
  1155.           (cond ((> have want) (go NEXT)))
  1156.           )))
  1157.     (cond ((< have want) (setq real-min (- real-min 1))))
  1158.     (dolist (v vars)
  1159.         (cond ((< (the fixnum (var-register v))
  1160.               real-min)
  1161.            (setf (var-register v) 0))))
  1162.     (return-from analyze-regs1  real-min)
  1163.      NEXT
  1164.     (setq have 0)
  1165.     (setq real-min (the fixnum (+ this-min 1)))
  1166.         (setq this-min 1000000)
  1167.     (go START)
  1168. )))
  1169.  
  1170.  
  1171.  
  1172. (defun wt-global-entry (fname cfun arg-types return-type)
  1173.     (cond ((get fname 'no-global-entry)(return-from wt-global-entry nil)))
  1174.     (wt-comment "global entry for the function " fname)
  1175.     (wt-nl1 "static L" cfun "()")
  1176.     (wt-nl1 "{    register object *base=vs_base;")
  1177.     (when (or *safe-compile* *compiler-check-args*)
  1178.           (wt-nl "check_arg(" (length arg-types) ");"))
  1179.     (wt-nl "base[0]=" (case return-type
  1180.                             (fixnum (if (zerop *space*)
  1181.                                         "CMPmake_fixnum"
  1182.                                         "make_fixnum"))
  1183.                             (character "code_char")
  1184.                             (long-float "make_longfloat")
  1185.                             (short-float "make_shortfloat")
  1186.                             (otherwise ""))
  1187.            "(LI" cfun "(")
  1188.     (do ((types arg-types (cdr types))
  1189.          (n 0 (1+ n)))
  1190.         ((endp types))
  1191.         (declare (object types) (fixnum n))
  1192.         (wt (case (car types)
  1193.                   (fixnum "fix")
  1194.                   (character "char_code")
  1195.                   (long-float "lf")
  1196.                   (short-float "sf")
  1197.                   (otherwise ""))
  1198.             "(base[" n "])")
  1199.         (unless (endp (cdr types)) (wt ",")))
  1200.     (wt "));")
  1201.     (wt-nl "vs_top=(vs_base=base)+1;")
  1202.     (wt-nl1 "}")
  1203.     )
  1204.  
  1205. (defun rep-type (type)
  1206.        (case type
  1207.              (fixnum "int ")
  1208.          (integer "GEN ")
  1209.              (character "unsigned char ")
  1210.              (short-float "float ")
  1211.              (long-float "double ")
  1212.              (otherwise "object ")))
  1213.  
  1214.  
  1215. (defun t1defmacro (args)
  1216.   (when (or (endp args) (endp (cdr args)))
  1217.         (too-few-args 'defmacro 2 (length args)))
  1218.   (cmpck (not (symbolp (car args)))
  1219.          "The macro name ~s is not a symbol." (car args))
  1220.   (maybe-eval t (cons 'defmacro args))
  1221.   (setq *non-package-operation* t)
  1222.   (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
  1223.         (*sharp-commas* nil) (*special-binding* nil)
  1224.         macro-lambda (cfun (next-cfun)))
  1225.        (setq macro-lambda (c1dm (car args) (cadr args) (cddr args)))
  1226.        (add-load-time-sharp-comma)
  1227.        (push (list 'defmacro (car args) cfun (cddr macro-lambda)
  1228.            (car macro-lambda)   ;doc
  1229.            (cadr macro-lambda)  ; ppn
  1230.                    *special-binding*)
  1231.              *top-level-forms*))
  1232.   )
  1233.  
  1234.  
  1235. (defun t2defmacro (fname cfun macro-lambda doc ppn sp)
  1236.  
  1237.   (declare (ignore macro-lambda sp))
  1238.   (when doc (add-init `(si::putprop ',fname ,doc 'si::function-documentation) ))
  1239.   (when ppn
  1240.     (add-init `(si::putprop ',fname ',ppn 'si::pretty-print-format) ))
  1241.   (wt-h "static L" cfun "();")
  1242.   (add-init `(si::MM ',fname ,(add-address "L" cfun)) )
  1243.   )
  1244.  
  1245. (defun t3defmacro (fname cfun macro-lambda doc ppn sp
  1246.                          &aux (*volatile* (if (get fname 'contains-setjmp)
  1247.                           " VOL " "")))
  1248.   (declare (ignore doc ppn))
  1249.   (let-pass3
  1250.    ((*exit* 'return))
  1251.    (wt-comment "macro definition for " fname)
  1252.    (wt-nl1 "static L" cfun "()")
  1253.    (wt-nl1 "{register object *" *volatile* "base=vs_base;")
  1254.    (assign-down-vars (info-referred-vars (nth 4 macro-lambda)) cfun ;*dm-info*
  1255.              't3defun)
  1256.    (wt-nl "register object *"*volatile* "sup=base+VM" *reservation-cmacro* ";")
  1257.    (wt " VC" *reservation-cmacro*)
  1258.    (if *safe-compile*
  1259.        (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  1260.      (wt-nl "vs_check;"))
  1261.    (when sp (wt-nl "bds_check;"))
  1262.    (when *compiler-push-events* (wt-nl "ihs_check;"))
  1263.    (c2dm (car macro-lambda) (cadr macro-lambda) (caddr macro-lambda)
  1264.      (cadddr macro-lambda))
  1265.    (wt-nl1 "}")
  1266.    (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  1267.    (wt-h "#define VC" *reservation-cmacro*)
  1268.    (wt-cvars)
  1269.  
  1270.    ))
  1271.  
  1272.  
  1273.  
  1274. (defun t1ordinary (form &aux tem )
  1275.   (setq *non-package-operation* t)
  1276.   ;; check for top level functions
  1277.   (cond (*compile-ordinaries*
  1278.      (maybe-eval nil form)
  1279.      (let ((gen (gensym "progn 'compile")))
  1280.        (proclaim `(function ,gen nil t))
  1281.        (t1expr `(defun ,gen (), form nil))
  1282.        (push (list 'ordinary `(,gen) ) *top-level-forms*)))
  1283.     ;;Hack to things like (setq bil #'(lambda () ...)) or (foo nil #'(lambda () ..))
  1284.     ;; but not (let ((x ..)) (setq bil #'(lambda () ..)))
  1285.     ;; for the latter you must use (progn 'compile ...)
  1286.     ((and (consp form)
  1287.           (symbolp (car form))
  1288.           (or (eq (car form) 'setq)
  1289.           (not (special-form-p (car form))))
  1290.           (do ((v (cdr form) (and (consp v) (cdr v)))
  1291.            (i 1 (the fixnum (+ 1 i))))
  1292.           ((or (>= i 1000)
  1293.                (not (consp v))) nil)
  1294.           (declare (fixnum i))
  1295.           (cond ((and (consp (car v))
  1296.                   (eq (caar v) 'function)
  1297.                   (consp (setq tem (second (car v))))
  1298.                   (eq (car tem) 'lambda))
  1299.              (let ((gen (gensym)))
  1300.                (t1expr `(defun ,gen ,@ (cdr tem)))
  1301.                (return-from t1ordinary
  1302.                     (t1ordinary (append
  1303.                              (subseq form 0 i)
  1304.                              `((symbol-function ', gen))
  1305.                              (nthcdr (+ 1 i) form))))))))))
  1306.     (t 
  1307.      (maybe-eval nil form)
  1308.      (let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil)
  1309.            (*sharp-commas* nil))
  1310.        (push (list 'ordinary  form) *top-level-forms*)
  1311.        nil
  1312.        ))))
  1313.  
  1314. (defun t2ordinary (form)
  1315.   (cond ((atom form))
  1316.     ((constantp form) )
  1317.     (t (add-init form ))))
  1318.   
  1319.   )
  1320.  
  1321. (defun add-load-time-sharp-comma ()
  1322.   (dolist* (vv (reverse *sharp-commas*))
  1323.        (cond ((atom vv) (wfs-error)))
  1324.     (push (cons 'sharp-comma vv) *top-level-forms*)))
  1325.  
  1326. (defun t2sharp-comma (vv val)
  1327.   (add-init `(si::setvv ,vv ,val) ))
  1328.  
  1329. (defun t2declare (vv) vv
  1330.   (wfs-error))
  1331.  
  1332. ;; Some top level functions which should be eval'd in the :default case
  1333. ;; for eval-when
  1334. (setf (get 'si::*make-special 'eval-at-compile) t)
  1335. (setf (get 'si::*make-constant 'eval-at-compile) t)
  1336. (setf (get 'proclaim 'eval-at-compile) t)
  1337.  
  1338.  
  1339. (setf (get 'si::define-structure 't1) 't1define-structure)
  1340.  
  1341. (defun t1define-structure (args)
  1342.   (maybe-eval t `(si::define-structure ,@args ,(not (maybe-eval nil nil))))
  1343.   (t1ordinary (cons 'si::define-structure args)))
  1344.  
  1345.  
  1346. (si:putprop 'dbind 'set-dbind 'set-loc)
  1347.  
  1348. (defun set-dbind (loc vv)
  1349.   (wt-nl "VV[" vv "]->s.s_dbind = " loc ";"))
  1350.  
  1351. (defun t1clines (args)
  1352.   (dolist** (s args)
  1353.     (cmpck (not (stringp s)) "The argument to CLINE, ~s, is not a string." s))
  1354.   (push (list 'clines args) *top-level-forms*))
  1355.  
  1356. (defun t3clines (ss) (dolist** (s ss) (wt-nl1 s)))
  1357.  
  1358. (defun t1defcfun (args &aux (body nil))
  1359.   (when (or (endp args) (endp (cdr args)))
  1360.         (too-few-args 'defcfun 2 (length args)))
  1361.   (cmpck (not (stringp (car args)))
  1362.          "The first argument to defCfun ~s is not a string." (car args))
  1363.   (cmpck (not (numberp (cadr args)))
  1364.          "The second argument to defCfun ~s is not a number." (cadr args))
  1365.   (dolist** (s (cddr args))
  1366.     (cond ((stringp s) (push s body))
  1367.           ((consp s)
  1368.            (cond ((symbolp (car s))
  1369.                   (cmpck (special-form-p (car s))
  1370.                          "Special form ~s is not allowed in defCfun." (car s))
  1371.                   (push (list (cons (car s) (parse-cvspecs (cdr s)))) body))
  1372.                  ((and (consp (car s)) (symbolp (caar s))
  1373.                        (not (if (eq (caar s) 'quote)
  1374.                                 (or (endp (cdar s))
  1375.                                     (not (endp (cddar s)))
  1376.                                     (endp (cdr s))
  1377.                                     (not (endp (cddr s))))
  1378.                                 (special-form-p (caar s)))))
  1379.                   (push (cons (cons (caar s)
  1380.                                     (if (eq (caar s) 'quote)
  1381.                                         (list (add-object (cadar s)))
  1382.                                         (parse-cvspecs (cdar s))))
  1383.                               (parse-cvspecs (cdr s)))
  1384.                         body))
  1385.                  (t (cmperr "The defCfun body ~s is illegal." s))))
  1386.           (t (cmperr "The defCfun body ~s is illegal." s))))
  1387.   (push (list 'defcfun (car args) (cadr args) (reverse body))
  1388.         *top-level-forms*)
  1389.   )
  1390.  
  1391. (defun t3defcfun (header vs-size body &aux fd)
  1392.   (wt-comment "C function defined by " 'defcfun)
  1393.   (wt-nl1 header)
  1394.   (wt-nl1 "{")
  1395.   (wt-nl1 "object *vs=vs_top;")
  1396.   (wt-nl1 "object *old_top=vs_top+" vs-size ";")
  1397.   (when (> vs-size 0) (wt-nl "vs_top=old_top;"))
  1398.   (wt-nl1 "{")
  1399.   (dolist** (s body)
  1400.     (cond ((stringp s) (wt-nl1 s))
  1401.           ((eq (caar s) 'quote)
  1402.            (wt-nl1 (cadadr s))
  1403.            (case (caadr s)
  1404.                  (object (wt "=VV[" (cadar s) "];"))
  1405.                  (otherwise
  1406.                   (wt "=object_to_" (string-downcase (symbol-name (caadr s)))
  1407.                       "(VV[" (cadar s) "]);"))))
  1408.           (t (wt-nl1 "{vs_base=vs_top=old_top;")
  1409.              (dolist** (arg (cdar s))
  1410.                (wt-nl1 "vs_push(")
  1411.                (case (car arg)
  1412.                      (object (wt (cadr arg)))
  1413.                      (char (wt "code_char((int)" (cadr arg) ")"))
  1414.                      (int (when (zerop *space*) (wt "CMP"))
  1415.                           (wt "make_fixnum((int)" (cadr arg) ")"))
  1416.                      (float (wt "make_shortfloat((double)" (cadr arg) ")"))
  1417.                      (double (wt "make_longfloat((double)" (cadr arg) ")")))
  1418.                (wt ");"))
  1419.              (cond ((setq fd (assoc (caar s) *global-funs*))
  1420.                     (cond (*compiler-push-events*
  1421.                            (wt-nl1 "ihs_push(VV[" (add-symbol (caar s)) "]);")
  1422.                            (wt-nl1 "L" (cdr fd) "();")
  1423.                            (wt-nl1 "ihs_pop();"))
  1424.                           (t (wt-nl1 "L" (cdr fd) "();"))))
  1425.                    (*compiler-push-events*
  1426.                     (wt-nl1 "super_funcall(VV[" (add-symbol (caar s)) "]);"))
  1427.                    (*safe-compile*
  1428.                     (wt-nl1 "super_funcall_no_event(VV[" (add-symbol (caar s))
  1429.                                                         "]);"))
  1430.                    (t (wt-nl1 "CMPfuncall(VV[" (add-symbol (caar s))
  1431.                                               "]->s.s_gfdef);"))
  1432.                    )
  1433.              (unless (endp (cdr s))
  1434.                (wt-nl1 (cadadr s))
  1435.                (case (caadr s)
  1436.                      (object (wt "=vs_base[0];"))
  1437.                      (otherwise (wt "=object_to_"
  1438.                                     (string-downcase (symbol-name (caadr s)))
  1439.                                     "(vs_base[0]);")))
  1440.                (dolist** (dest (cddr s))
  1441.                  (wt-nl1 "vs_base++;")
  1442.                  (wt-nl1 (cadr dest))
  1443.                  (case (car dest)
  1444.                        (object
  1445.                         (wt "=(vs_base<vs_top?vs_base[0]:Cnil);"))
  1446.                        (otherwise
  1447.                         (wt "=object_to_"
  1448.                             (string-downcase (symbol-name (car dest)))
  1449.                             "((vs_base<vs_top?vs_base[0]:Cnil));"))))
  1450.                )
  1451.              (wt-nl1 "}")
  1452.              )))
  1453.   (wt-nl1 "}")
  1454.   (wt-nl1 "vs_top=vs;")
  1455.   (wt-nl1 "}")
  1456.   )
  1457.  
  1458. (defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec)
  1459.   (when (or (endp args) (endp (cdr args)) (endp (cddr args)))
  1460.         (too-few-args 'defentry 3 (length args)))
  1461.   (cmpck (not (symbolp (car args)))
  1462.          "The function name ~s is not a symbol." (car args))
  1463.   (dolist** (x (cadr args))
  1464.     (cmpck (not (member x '(object char int float double string)))
  1465.            "The C-type ~s is illegal." x))
  1466.   (setq cfspec (caddr args))
  1467.   (cond ((symbolp cfspec)
  1468.          (setq type 'object)
  1469.          (setq cname (string-downcase (symbol-name cfspec))))
  1470.         ((stringp cfspec)
  1471.          (setq type 'object)
  1472.          (setq cname cfspec))
  1473.         ((and (consp cfspec)
  1474.               (member (car cfspec) '(void object char int float double
  1475.                       string))
  1476.               (consp (cdr cfspec))
  1477.               (or (symbolp (cadr cfspec)) (stringp (cadr cfspec)))
  1478.               (endp (cddr cfspec)))
  1479.          (setq cname (if (symbolp (cadr cfspec))
  1480.                         (string-downcase (symbol-name (cadr cfspec)))
  1481.                         (cadr cfspec)))
  1482.          (setq type (car cfspec)))
  1483.         (t (cmperr "The C function specification ~s is illegal." cfspec)))
  1484.   (push (list 'defentry (car args) cfun (cadr args) type cname)
  1485.         *top-level-forms*)
  1486.   (push (cons (car args) cfun) *global-funs*)
  1487.   )
  1488.  
  1489. (defun t2defentry (fname cfun arg-types type cname)
  1490.   (declare (ignore arg-types type cname))
  1491.   (wt-h "static L" cfun "();")
  1492.   (add-init `(si::mf ',fname ,(add-address "L" cfun)) )
  1493.   )
  1494.  
  1495. (defun t3defentry (fname cfun arg-types type cname)
  1496.   (wt-comment "function definition for " fname)
  1497.   (wt-nl1 "static L" cfun "()")
  1498.   (wt-nl1 "{    object *old_base=vs_base;")
  1499.   (case type
  1500.     (void)
  1501.     (string (wt-nl "char *x;"))
  1502.     (t (wt-nl (string-downcase (symbol-name type)) " x;")))
  1503.   (when *safe-compile* (wt-nl "check_arg(" (length arg-types) ");"))
  1504.   (unless (eq type 'void) (wt-nl "x="))
  1505.   (wt-nl cname "(")
  1506.   (unless (endp arg-types)
  1507.           (do ((types arg-types (cdr types))
  1508.                (i 0 (1+ i)))
  1509.               (nil)
  1510.               (declare (object types) (fixnum i))
  1511.               (case (car types)
  1512.                     (object (wt-nl "vs_base[" i "]"))
  1513.                     (otherwise
  1514.                      (wt-nl "object_to_"
  1515.                             (string-downcase (symbol-name (car types)))
  1516.                             "(vs_base[" i "])")))
  1517.               (when (endp (cdr types)) (return))
  1518.               (wt ",")))
  1519.   (wt ");")
  1520.   (wt-nl "vs_top=(vs_base=old_base)+1;")
  1521.   (wt-nl "vs_base[0]=")
  1522.   (case type
  1523.         (void (wt "Cnil"))
  1524.         (object (wt "x"))
  1525.         (char (wt "code_char(x)"))
  1526.         (int (when (zerop *space*) (wt "CMP"))
  1527.              (wt "make_fixnum(x)"))
  1528.     (string
  1529.       (wt "make_simple_string(x)"))
  1530.         (float (wt "make_shortfloat(x)"))
  1531.         (double (wt "make_longfloat(x)"))
  1532.         )
  1533.   (wt ";")
  1534.   (wt-nl1 "}")
  1535.   )
  1536.  
  1537. (defun t1defla (args) (declare (ignore args)))
  1538.  
  1539. (defun parse-cvspecs (x &aux (cvspecs nil))
  1540.   (dolist** (cvs x (reverse cvspecs))
  1541.     (cond ((symbolp cvs)
  1542.            (push (list 'object (string-downcase (symbol-name cvs))) cvspecs))
  1543.           ((stringp cvs) (push (list 'object cvs) cvspecs))
  1544.           ((and (consp cvs)
  1545.                 (member (car cvs) '(object char int float double)))
  1546.            (dolist** (name (cdr cvs))
  1547.              (push (list (car cvs)
  1548.                          (cond ((symbolp name)
  1549.                                 (string-downcase (symbol-name name)))
  1550.                                ((stringp name) name)
  1551.                                (t (cmperr "The C variable name ~s is illegal."
  1552.                                           name))))
  1553.                    cvspecs)))
  1554.           (t (cmperr "The C variable specification ~s is illegal." cvs))))
  1555.   )
  1556.  
  1557.  
  1558.  
  1559. (defun t3local-dcfun (closure-p clink ccb-vs fun lambda-expr
  1560.                               &aux (level (if closure-p 0 (fun-level fun)))
  1561.                   cm
  1562.              (*volatile* (volatile (cadr lambda-expr)))
  1563.          *downward-closures*
  1564.          (requireds (caaddr lambda-expr)))
  1565.   (wt-comment "local dc function " (if (fun-name fun) (fun-name fun) nil))
  1566.   (wt-nl1 "static " (if closure-p "LC" "L") (fun-cfun fun) "(")
  1567.   (wt "base0" (if requireds "," ""))
  1568.   (analyze-regs (info-referred-vars (cadr lambda-expr)) 2)
  1569.   (wt-requireds (caaddr lambda-expr) nil) ;;nil = arg types all t
  1570.   (wt "register object *" *volatile* "base0;")
  1571.   (let-pass3
  1572.    ((*exit* 'return-object)
  1573.     (*clink* clink)(*ccb-vs* ccb-vs)
  1574.     (*level* (1+ level))(*initial-ccb-vs* ccb-vs))
  1575.    (setq cm *reservation-cmacro*)
  1576.        (wt-nl1 "{")
  1577.        (assign-down-vars
  1578.     (info-referred-vars (cadr lambda-expr)) (fun-cfun fun) 't3local-dcfun)
  1579.         (wt-nl  "VMB" cm " VMS" cm " VMV" cm )
  1580.     (when *compiler-push-events* (wt-nl "ihs_check;"))
  1581.     (c2expr (caddr (cddr lambda-expr)))
  1582.     ;(c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)))
  1583.     (wt-nl1 "}")
  1584.     (wt-V*-macros cm t)
  1585.     (wt-downward-closure-macro (fun-cfun fun))
  1586.   ))
  1587.  
  1588.  
  1589. (defun t3local-fun (closure-p clink ccb-vs fun lambda-expr
  1590.                               &aux (level (if closure-p 0 (fun-level fun)))
  1591.                   (*volatile* (volatile (cadr lambda-expr)))
  1592.                   *downward-closures*)
  1593.   (declare (fixnum level))
  1594.   (if (eq closure-p 'dclosure)
  1595.       (return-from t3local-fun
  1596.            (t3local-dcfun closure-p clink ccb-vs fun lambda-expr)))
  1597.   (wt-comment "local function " (if (fun-name fun) (fun-name fun) nil))
  1598.   (wt-h   "static " (if closure-p "LC" "L") (fun-cfun fun) "();")
  1599.   (wt-nl1 "static " (if closure-p "LC" "L") (fun-cfun fun) "(")
  1600.   (dotimes* (n level (wt "base" n ")")) (wt "base" n ","))
  1601.   (wt-nl1  "register object ")
  1602.   (dotimes* (n level (wt "*"*volatile*"base" n ";"))
  1603.         (wt "*"*volatile*"base" n ","))
  1604.   (analyze-regs (info-referred-vars (cadr lambda-expr)) 2)
  1605.   (let-pass3
  1606.    ((*clink* clink) (*ccb-vs* ccb-vs)
  1607.     (*level* (1+ level)) (*initial-ccb-vs* ccb-vs)
  1608.     (*exit* 'return))
  1609.    (wt-nl1 "{    register object *"*volatile*"base=vs_base;")
  1610.    (wt-nl  "register object *" *volatile* "sup=base+VM" *reservation-cmacro* ";")
  1611.    (assign-down-vars (info-referred-vars (cadr lambda-expr)) (fun-cfun fun)
  1612.              't3local-fun)
  1613.    (wt " VC" *reservation-cmacro*)
  1614.    (if *safe-compile*
  1615.        (wt-nl "vs_reserve(VM" *reservation-cmacro* ");")
  1616.      (wt-nl "vs_check;"))
  1617.    (when *compiler-push-events* (wt-nl "ihs_check;"))
  1618.    (if closure-p
  1619.        (c2lambda-expr (lambda-list lambda-expr) (caddr (cddr lambda-expr)))
  1620.      (c2lambda-expr (lambda-list lambda-expr)
  1621.             (caddr (cddr lambda-expr)) fun))
  1622.    (wt-nl1 "}")
  1623.    (push (cons *reservation-cmacro* *max-vs*) *reservations*)
  1624.    (wt-h "#define VC" *reservation-cmacro*)
  1625.    (wt-cvars)
  1626.    )
  1627.   (wt-downward-closure-macro (fun-cfun fun))
  1628.   )
  1629.  
  1630. (defun wt-cvars( &aux type )
  1631.   (dolist (v *c-vars*)
  1632.      (let ((t1 (if (consp v) (prog1 (car v) (setq v (cdr v))) t)))
  1633.        (cond ((eq type t1)(format *compiler-output2* " ,V~a" v))
  1634.          (t (or (null type)
  1635.             (format *compiler-output2* ";"))
  1636.         (setq type t1)
  1637.         (format *compiler-output2* " ~a V~a"
  1638.                        (rep-type type) v)))
  1639.        (cond ((eq type 'integer)
  1640.           (format *compiler-output2* "= 0,V~aalloc" v)
  1641.           ))
  1642.        ))
  1643.  (and *c-vars* (format *compiler-output2* ";"))
  1644.  (unless (eql *cs* 0)
  1645.      (format *compiler-output2* " object Vcs[~a];" *cs*))
  1646.   )
  1647.  
  1648.  
  1649.  
  1650.